(in-package :ws-sql)

(declaim (optimize (debug 3) (safety 3)))

(defun transcribe-wsdl (procedures) 
;;; XXX break up this function into more undestandable/resusable parts
  "Given a ResultSet of procedures as returned from
  DatabaseMetadata.getProcedures(), return the values (wsdl xsd) which
  are hashtables representing desired Web Service interfaces that can
  be instantiated as valid XML documents by INSTANTIATE-WSDL and INSTANTIATE-XSD "
  (let ((wsdl (make-hash-table))
	(xsd (make-hash-table)))
    (dolist (column procedures)
      (let ((catalog (first column))
	    (schema (second column))
	    (name (third column))
	    (remarks (seventh column)))
	(verbose "transcribing:~%~A" 
		 (list catalog schema name remarks))
	(let* ((description 
		(get-procedure-descriptions 
		 :catalog catalog :schema-pattern schema :procedure-name-pattern name))
	       (name-request (format nil "~A_~A_~A" schema catalog name))
	       (name-response (format nil "~A_Response"
				      name-request))
	       (short-name (format nil "~A-~A" 
				     (string-downcase catalog)
				     (string-downcase name)))
	       (target-namespace (format nil
					 "http://logos.etel.at/~A/"
					 short-name)))
  	  (setf (gethash :target-namespace wsdl) target-namespace
		(gethash :target-namespace xsd)  target-namespace
		(gethash :short-name wsdl)       short-name
		(gethash :short-name xsd)        short-name
		(gethash :schema wsdl)           schema
		(gethash :schema xsd)            schema
		(gethash :catalog wsdl)          catalog
		(gethash :catalog xsd)           catalog)
	  (multiple-value-bind (inputs outputs) 
		(serialize-procedure-description-from-result-set
		 description)
	    (let ((inputs (normalize-parameters inputs))
		  (outputs (normalize-parameters outputs)))
	      (multiple-value-bind (element type)
		  (create-xsd-types name-request inputs)
		(add-message wsdl (create-message name-request))
		(add-operations wsdl name-request name-response)
		(add-type xsd type)
		(add-element xsd element))
	      (multiple-value-bind (element type)
		  (create-xsd-types name-response outputs)
		(add-message wsdl (create-message name-response))
		(add-type xsd type)
		(add-element xsd element)))))))
    (values wsdl xsd)))

(defun transcribe-wsdl-as-xml (procedures)
  (multiple-value-bind (wsdl xsd)
      (transcribe-wsdl procedures)
    (values (wsdl-instantiate wsdl)
	    (xsd-instantiate xsd))))

(defun normalize-parameters (parameters)
  "Normalize the name of parameters in a WSDL call as scraped from the
JDBC call.

1.  Any name NIL gets renamed as CARDINALTIY 

2.  Any duplicated name gets each instance renamed as CARDINALITY-name

where CARDINALITY is the result of using the FORMAT '~:R' operator on
the base-one occurence of the parameter in the list.
"
  (loop 
     :for parameter :in parameters
     :for i :upfrom 1
     :with duplicates 
     :collect (macrolet
		  ((name (p) `(car ,p))
		   (prefix-cardinality (symbol i)
		     `(format nil "~:R-~A" ,i ,symbol)))
		(let* ((p (copy-seq parameter)))
		       (cond 
			 ;; Replace paramters named NIL with "CARDINALITY-parameter"
			 ((null (name p))
			  (setf (name p) 
				(format nil "~:R-parameter" i)))
			 ;; If this parmeter is a duplicate, rename it
			 ;; as "CARDINALITY-PARAMETER-NAME"
			 ((find (name p) duplicates :test #'equal)
			   (setf (name p) 
				 (prefix-cardinality (name p) i)))
			 ;; If this parameter has a duplicate further
			 ;; down the list, save its name in the
			 ;; DUPLICATES list, and rename it as
			 ;; "CARDINALITY-PARAMETER-NAME" 
			  ((position p parameters :test #1'equal :start i)
			   (progn 
			     (push (name p) duplicates)
			     (setf (name p) (prefix-cardinality (name p) i)))))
			  p))))

(defun append-to-hash-value (hash key value)
   (if (not (gethash key hash))
       (setf (gethash key hash) (list value))
       (setf (gethash key hash) 
	     (append (gethash key hash) (list value)))))

(defun add-message (wsdl name)
  (append-to-hash-value wsdl :messages name))

(defun add-type (xsd type)
  (append-to-hash-value xsd :types type))

(defun add-element (xsd element)
  (append-to-hash-value xsd :elements element))

(defun add-operations (wsdl name name-response)
  (multiple-value-bind (port-type binding)
      (create-operations name name-response)
    (append-to-hash-value wsdl :port-types port-type)
    (append-to-hash-value wsdl :bindings binding)))

(defun create-message (name)
   `((:|message| 
       :|name| ,name)
     ((:|part| 
       :|name| "parameters"
       :|element| ,(format nil "tns:~a" name)))))

(defun create-operations (name name-response)
  (values 
   `((:|operation| :|name| ,name)
     ((:|input| :|message| ,(format nil "tns:~a" name)))
     ((:|output| :|message| ,(format nil "tns:~a" name-response))))
   `((:|operation| :|name| ,name)
     ((soap:|operation| :|soapAction| ""))
     ((:|input|)
      ((soap:|body| :|use| "literal")))
     ((:|output|)
      ((soap:|body| :|use| "literal"))))))

(defun create-xsd-types (procedure_name params)
  (let ((element 
	 `((xsd:|element| 
	       :|name| ,procedure_name
	       :|type| ,(format nil "tns:~A" procedure_name))))
	(elements
	 (loop 
	    :for param :in params 
	    :for i :upfrom 1
	    collecting 
	    (let ((name (first param))
		  (type (second param)))
	      (if (null name)
		  (setf name (format nil "~:R-parameter" i)))
	      `((xsd:|element|
		    :|name| ,name
		    :|type| ,(sql-type->xsd type)
		    :|minOccurs| "0"))))))
    (let ((type 
	   `((xsd:|complexType| 
		  :|name| ,procedure_name)
	     ((xsd:|sequence|) ,@elements))))
      (values element type))))

(defconstant +ws-sql-oracle-types-ns+ "urn:ws-sql-oracle-types")
(defconstant +ws-sql-oracle-types-xsd-location+ "ws-sql-oracle-types.xsd")
      
;(wsdl-location wsdl :schema-location "foo.xsd") 

(defun generate-documentation (hash) 
  (format nil "Generated ~:@/cl-l10n:format-time/ from schema ~A in ~
catalog ~A"
	  (get-universal-time)
	  (gethash :schema hash)
	  (gethash :catalog hash)))

(defun wsdl-instantiate (wsdl 
			 &key (schema-location "schema.xsd")
			 documentation)
  (let* ((target-namespace (gethash :target-namespace wsdl))
	 (short-name (gethash :short-name wsdl))
	 (service-name (format nil "~AService" short-name))
	 (messages (gethash :messages wsdl))
	 (binding-name (format nil "~ABinding" short-name))
	 (binding-type (format nil "tns:~A" short-name))
	 (port-type-name short-name)
	 (port-type-operations (gethash :port-types wsdl))
	 (binding-operations (gethash :bindings wsdl))
	 (port-name (format nil "~APort" short-name))
	 (port-url "REPLACE_WITH_ACTUAL_URL")
	 (documentation (when (null documentation)
			  (generate-documentation wsdl))))
  `((:|definitions| 
      :|targetNamespace| ,target-namespace
      :|name| ,service-name
      :|xmlns| ,+wsdl-ns-uri+
      :|xmlns:tns| ,target-namespace
      :|xmlns:xsd| ,+xsd-ns-uri+
      :|xmlns:soap| ,+soap-ns-uri+)
    ((:|documentation|) ,documentation)
    ((:|types|)
     ((xsd:|schema|)
      ((xsd:|import|
	    :|namespace| ,target-namespace
	    :|schemaLocation| ,schema-location))))
    ,@messages
    ((:|portType|
       :|name| ,port-type-name)
     ,@port-type-operations)
    ((:|binding| 
       :|name| ,binding-name
       :|type| ,binding-type)
     ((:|soap:binding| 
       :|transport| "http://schemas.xmlsoap.org/soap/http"
       :|style| "document"))
      ,@binding-operations)
    ((:|service|
       :|name| ,service-name)
     ((:|port| 
       :|name| ,port-name
       :|binding| ,(format nil "tns:~A" binding-name))
      ((:|soap:address|
	:|location| ,port-url)))))))

(defun xsd-instantiate (xsd &key documentation)
  (let ((types (gethash :types xsd))
	(database-types-schema-location "ws-sql-oracle-types.xsd")
	(elements (gethash :elements xsd))
	(target-namespace (gethash :target-namespace xsd))
	(documentation (when (null documentation)
			 (generate-documentation xsd))))
    `((:|xsd:schema| 
	:|version| "1.0"
	:|targetNamespace| ,target-namespace
	:|xmlns:tns| ,target-namespace
	:|xmlns:plsql| ,+ws-sql-oracle-types-ns+
	:|xmlns:xsd| ,+xsd-ns-uri+)
      ((xsd:|annotation|) 
       ((xsd:|documentation|) ,documentation))
      ((xsd:|import|
	    :|namespace| ,+ws-sql-oracle-types-ns+
	    :|schemaLocation| ,+ws-sql-oracle-types-xsd-location+))
      ,@elements
      ,@types)))
